home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / svgadc30.zip / edit256.pas < prev    next >
Pascal/Delphi Source File  |  1993-03-03  |  9KB  |  321 lines
  1. program Edit_256_Palette;
  2.  
  3. { This program lets you edit a 256 colour palette }
  4. { The keys to use are as follows :                }
  5. {   Use arrow keys to move around.                }
  6. {                                                 }
  7. {   Increase color  F    G    H                   }
  8. {   Decrease color   V    B    N                  }
  9. {                  Red   Grn   Blu                }
  10. {                                                 }
  11. {   Press 'p' to get into "Pan" mode              }
  12. {   Press 'p' again to mark first color           }
  13. {   Move to second color and press 'p' to mark    }
  14. {   The colors between these two markers will be  }
  15. {   "panned". If you don't understand then just   }
  16. {   try it!                                       }
  17. {   Press 'c' to get into "Copy" mode             }
  18. {   Press 'c' again to mark first color           }
  19. {   Move to target palette and press press 'c'    }
  20. {   again to copy color                           }
  21. {   Press 'q' to quit                             }
  22. {   Press 's' to save a pallette                  }
  23. {   The program is not very user friendly but it  }
  24. {   does the job!                                 }
  25.  
  26. uses SVGA, Dos, crt;
  27.  
  28. const x1 = 30; x2 = 90;
  29.       y1 = 260; y2 = 290;
  30.       Red = 252;
  31.       Green = 253;
  32.       Blue = 254;
  33.       White = 255;
  34.  
  35. var i, j, Rx, Ry : integer;
  36.     register : registers;
  37.     Colors : RGB;
  38.     XPos, YPos, OldXPos, OldYPos : byte;
  39.     Ch : char;
  40.     PaletteName : string;
  41.  
  42. procedure ShowCol( Col : RGB );
  43.  
  44.   begin
  45.     Line( 51, 150, 51, 20, 0 );
  46.     Line( 52, 150, 52, 20, 0 );
  47.     Line( 58, 150, 58, 20, 0 );
  48.     Line( 59, 150, 59, 20, 0 );
  49.     Line( 65, 150, 65, 20, 0 );
  50.     Line( 66, 150, 66, 20, 0 );
  51.     Line( 51, 150, 51, 150-Col.Red*2, red );
  52.     Line( 52, 150, 52, 150-Col.Red*2, red );
  53.     Line( 58, 150, 58, 150-Col.Grn*2, Green );
  54.     Line( 59, 150, 59, 150-Col.Grn*2, Green );
  55.     Line( 65, 150, 65, 150-Col.Blu*2, Blue );
  56.     Line( 66, 150, 66, 150-Col.Blu*2, Blue );
  57.     RectFill( x1, y1, x2, y2, XPos+YPos );
  58.   end;
  59.  
  60. procedure ReadPal( PalNum : byte; var Col : RGB );
  61.  
  62. begin
  63.     Col.Grn := Color[PalNum].Grn;
  64.     Col.Blu := Color[PalNum].Blu;
  65.     Col.Red := Color[PalNum].Red;
  66. end;
  67.  
  68. {procedure ChangeColor( PalNum: byte; Hue : RGB );
  69.  
  70.   begin
  71.     with register do
  72.       begin
  73.         AX := $1010;
  74.         BX := PalNum;
  75.         CH := Hue.Grn;
  76.         CL := Hue.Blu;
  77.         DH := Hue.Red;
  78.       end;
  79.     intr( $10, register );
  80.   end;}
  81.  
  82. procedure PutCursor( X, Y, OldX, OldY : byte );
  83.  
  84.   begin
  85.     Rx := trunc(OldX/32)*50+150;
  86.     Ry := OldY*15;
  87.     Rectangle( Rx, Ry, Rx+49, Ry+14, OldX+OldY );
  88.     Rectangle( Rx+1, Ry+1, Rx+48, Ry+13, OldX+OldY );
  89.     Rx := trunc(X/32)*50+150;
  90.     Ry := Y*15;
  91.     Rectangle( Rx, Ry, Rx+49, Ry+14, Red );
  92.     Rectangle( Rx+1, Ry+1, Rx+48, Ry+13, White );
  93.     OldXPos := XPos; OldYPos := YPos;
  94.   end;
  95.  
  96. procedure GetKey;
  97.  
  98.   begin
  99.     Case Ch of
  100.         'K' : XPos := XPos - 32;
  101.         'M' : XPos := XPos + 32;
  102.         'H' : if (YPos-1) >= 0 then YPos := YPos - 1
  103.                else YPos := 31;
  104.         'P' : if (YPos+1) <= 31 then YPos := YPos + 1
  105.                 else YPos := 0;
  106.     end;
  107.   end;
  108.  
  109. procedure Swap2( var A , B : byte );
  110.  
  111.   var swapper : byte;
  112.  
  113.   begin
  114.     swapper := A;
  115.     A := B;
  116.     B := swapper;
  117.   end;
  118.  
  119. procedure Pan;
  120.  
  121.   var Markers, Count, Start, Finish, Fx, Sx, Fy, Sy : byte;
  122.       R, G, B : real;
  123.       swap : boolean;
  124.  
  125.   begin
  126.     Markers := 0;
  127.     Count := 0;
  128.     repeat
  129.       Ch := ReadKey;
  130.       if Ch = 'p' then
  131.         begin
  132.           Markers := Markers + 1;
  133.           if Markers = 1 then
  134.             begin
  135.               Start := XPos + YPos;
  136.               Sx := XPos; Sy := YPos;
  137.             end
  138.           else
  139.             begin
  140.               Finish := XPos + YPos;
  141.               Fx := XPos; Fy := YPos;
  142.             end;
  143.           Rx := trunc(XPos/32)*50+170;
  144.           Ry := YPos*15+3;
  145.           RectFill( Rx, Ry, Rx+9, Ry+8, Red );
  146.           RectFill( Rx+2, Ry+1, Rx+7, Ry+7, White );
  147.         end;
  148.       if (Ch = #0) then
  149.       begin
  150.         Ch := ReadKey;
  151.         GetKey;
  152.         PutCursor( XPos, YPos, OldXPos, OldYPos );
  153.         ReadPal( XPos+YPos, Colors );
  154.         ShowCol( Colors );
  155.       end;
  156.     until Markers = 2;
  157.     if Start <> Finish then
  158.       begin
  159.         if Start > Finish then
  160.           begin
  161.             Swap2( Start, Finish );
  162.             Swap2( Sx, Fx );
  163.             Swap2( Sy, Fy );
  164.           end;
  165.         Markers := Start;
  166.         R := (Color[Finish].Red - Color[Start].Red) / abs(Finish - Start);
  167.         G := (Color[Finish].Grn - Color[Start].Grn) / abs(Finish - Start);
  168.         B := (Color[Finish].Blu - Color[Start].Blu) / abs(Finish - Start);
  169.         repeat
  170.           Colors := Color[Markers];
  171.           if (Color[Start].Red + Count*R) <= 63 then
  172.             Colors.Red := round(Color[Start].Red + Count*R)
  173.               else Colors.Red := 63;
  174.           if (Color[Start].Grn + Count*G) <= 63 then
  175.             Colors.Grn := round(Color[Start].Grn + Count*G)
  176.               else Colors.Grn := 63;
  177.           if (Color[Start].Blu + Count*B) <= 63 then
  178.             Colors.Blu := round(Color[Start].Blu + Count*B)
  179.               else Colors.Blu := 63;
  180.           SetColor( Markers, Colors );
  181.           Color[Markers] := Colors;
  182.           Count := Count + 1;
  183.           Markers := Markers + 1;
  184.         until Markers = Finish;
  185.         Rx := round((Start-Sy)/32)*50+170;
  186.         Ry := (Start-Sx)*15+3;
  187.         RectFill( Rx, Ry, Rx+9, Ry+8, Start );
  188.         Rx := round((Finish-Fy)/32)*50+170;
  189.         Ry := (Finish-Fx)*15+3;
  190.         RectFill( Rx, Ry, Rx+9, Ry+8, Finish );
  191.       end;
  192.   end;
  193.  
  194. procedure CopyPal;
  195.  
  196.   var Markers, Start, Finish, Sx, Sy, Fx, Fy: byte;
  197.  
  198.   begin
  199.     Markers := 0;
  200.     repeat
  201.       Ch := ReadKey;
  202.       if Ch = 'c' then
  203.         begin
  204.           Markers := Markers + 1;
  205.           if Markers = 1 then
  206.             begin
  207.               Start := XPos + YPos;
  208.               Sx := XPos; Sy := YPos;
  209.             end
  210.           else
  211.             begin
  212.               Finish := XPos + YPos;
  213.               Fx := XPos; Fy := YPos;
  214.             end;
  215.           Rx := trunc(XPos/32)*50+170;
  216.           Ry := YPos*15+3;
  217.           RectFill( Rx, Ry, Rx+9, Ry+8, Red );
  218.           RectFill( Rx+2, Ry+1, Rx+7, Ry+7, White );
  219.         end;
  220.       if (Ch = #0) then
  221.       begin
  222.         Ch := ReadKey;
  223.         GetKey;
  224.         PutCursor( XPos, YPos, OldXPos, OldYPos );
  225.         ReadPal( XPos+YPos, Colors );
  226.         ShowCol( Colors );
  227.       end;
  228.     until Markers = 2;
  229.     SetColor( Finish, Color[ Start ] );
  230.     Rx := round((Start-Sy)/32)*50+170;
  231.     Ry := (Start-Sx)*15+3;
  232.     RectFill( Rx, Ry, Rx+9, Ry+8, Start );
  233.     Rx := round((Finish-Fy)/32)*50+170;
  234.     Ry := (Finish-Fx)*15+3;
  235.     RectFill( Rx, Ry, Rx+9, Ry+8, Finish );
  236.   end;
  237.  
  238. procedure SavePal;
  239.  
  240.   var Fil : File of RGB;
  241.       t : byte;
  242.  
  243.   begin
  244.     assign( fil, PaletteName );
  245.     {$I-} rewrite( fil ); {$I+}
  246.     i := IOResult;
  247.     if i = 0 then
  248.       begin
  249.         for t := 0 to 255 do
  250.           write( fil, Color[t] );
  251.         Close( fil );
  252.       end;
  253.   end;
  254.  
  255. procedure SetUp;
  256.  
  257.   var ch : char;
  258.  
  259.   begin
  260.     write( 'Start New Palette ? ');
  261.     Ch := ReadKey;
  262.     if (Ch = 'n') OR (Ch = 'N') then
  263.       begin
  264.         clrscr;
  265.         write( 'Name of Existing Palette to work with : ' );
  266.         read( PaletteName );
  267.       end
  268.     else
  269.       begin
  270.         clrscr;
  271.         write( 'Name of New Palette : ');
  272.         read( PaletteName );
  273.       end;
  274.     SetMode( SVGA6448 );
  275.     if (Ch='n') OR (Ch='N') then LoadPalette( PaletteName )
  276.       else LoadPalette( 'pal256.002' );
  277.     for i := 0 to 7 do
  278.       for j := 0 to 31 do
  279.         RectFill( i*50+150, j*15, i*50+199, j*15+14, i*32+j );
  280.     OldXPos := 0; OldYPos :=20;
  281.     XPos := 0; YPos := 20;
  282.     PutCursor( XPos, YPos, 0, 0 );
  283.     ReadPal( XPos+YPos, Colors );
  284.     ShowCol( Colors );
  285.     RectFill( x1, y1, x2, y2, XPos+YPos );
  286.     Ch := 't';
  287.   end;
  288.  
  289. begin
  290.   SetUp;
  291.   repeat
  292.     Ch := ReadKey;
  293.     if C